home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / SystemCode / fortran.tcl < prev    next >
Text File  |  1996-01-25  |  21KB  |  660 lines
  1. #=============================================================================
  2. # Fortran mode definition and support procs
  3. #
  4. # Features:
  5. # 1.  Keyword colorization (slightly customizable)
  6. # 2.  Fortran-sensitive shift right/left preserve columns 1-6
  7. # 3.  Auto-indentation
  8. # 4.  Line-breaking with Ctl-Opt-J (a la emacs)
  9. # 5.  Subroutine indexing
  10. # 6.  Cmd-double-click subroutine and include-file lookup
  11. # 7.  Customizable comment and continuation characters
  12. #
  13. #------------------------------------------------------------------------------
  14. # Author: Tom Pollard <pollard@chem.columbia.edu>
  15. #
  16. # To Do:  work around grep failure for Unix-format tag files
  17. #
  18. #  1/96 - FortMarkFile no longer marks F90 "end subroutine ..." statements
  19. #         more F90 keywords (will they never cease?)
  20. #  1/96 - user-selectable comment and continuation characters
  21. #         complete F90 keyword set (Thomas Bewley <bewley@rayleigh.stanford.edu>) 
  22. #         F90 functions and comparison operators optionally colorized ( " " )
  23. #         more complete set of C preprocessor commands colorized
  24. #         fixed case-sensitivity problem in line-indent routines
  25. #  1/96 - minor FortDblClick bug fix
  26. # 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
  27. # 12/95 - cpp keyword colorization (George Nurser <g.nurser@soc.soton.ac.uk>)
  28. #         cmd-dbl-click supports cpp #include now
  29. # 11/95 - added FortBreakLine
  30. #         fixed case-sensitivity bug
  31. # 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
  32. #            improve performance (fortFindSub)
  33. #  9/95 - fixed getFortPrev bug with numbered lines
  34. #       - shiftLeft/Right revert to normal behavior on ill-formatted lines
  35. #  8/95 - auto-indentation is finally speedy and robust
  36. #  5/95 - added Cmd-Dbl-Click handler
  37. #       - added auto-indentation
  38. # 12/94 - fixed funcExpr, FortMarkFile search expressions
  39. #       - changed comment character from 'C' to 'c' (should be case-insensitive!)
  40. #       - added 'include' keyword
  41. #       - added FortShiftRight and FortShiftLeft procs
  42. #------------------------------------------------------------------------------
  43. proc dummyFort {} {}
  44.  
  45. newModeVar Fort sortedIsDefault    {0} 1
  46. newModeVar Fort wordWrap        {0}    1
  47. newModeVar Fort funcExpr    {^[^cC*!][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} 0
  48. newModeVar Fort autoMark        {0}    1
  49. newModeVar Fort electricTab        {1}    1
  50.  
  51. # newModeVar Fort    prefixString    {c}    0
  52. newModeVar Fort    continueChar    {$}    0
  53. newModeVar Fort    commentChar    {c}    0
  54. newModeVar Fort    colorFuncs    {0}    1
  55. newModeVar Fort    colorOpers    {0}    1
  56.  
  57. newModeVar Fort indentComment    {0}    1
  58. newModeVar Fort markTag            {{}} 0
  59.  
  60. #=============================================================================
  61. # Colorize Fortran keywords
  62. #
  63. proc fortColorKeywords {{color blue} {comment red} {specialChars black}} {
  64.     global FortmodeVars
  65.  
  66.     set FortKeywords { 
  67.         allocatable allocate assign backspace block call character close common 
  68.         complex contains continue cycle data deallocate dimension do double else 
  69.         elseif end enddo endfile endif entry equivalence exit external extrinsic 
  70.         forall format function goto if implicit include inquire integer intent 
  71.         interface intrinsic logical module namelist nullify open optional 
  72.         parameter pause pointer precision print private program public pure read 
  73.         real recursive return rewind save sequence stop subroutine target then 
  74.         use where while write assignment case default elsewhere endfile go none 
  75.         operator procedure select to type
  76.     }
  77.     
  78.     if {$specialChars == "black"} {
  79.         regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  -i {=}  -i {*}  -i {/}  -i {+}  -i {-}  -i {,}  -i {(} -i {)} -I $specialChars
  80.     } else {
  81.         regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  
  82.     }
  83.     unset FortKeywords
  84. } 
  85.  
  86. #=============================================================================
  87. # Colorize selected C preprocessor keywords
  88. #
  89. proc fortColorCPP {{color green}} {
  90.     set CPPKeywords  {
  91.         #if #endif #include #else #define #undef #ifdef #ifndef
  92.     }
  93.     regModeKeywords -a  -k $color Fort $CPPKeywords
  94.     unset CPPKeywords
  95. }
  96.  
  97.  
  98. #=========================================================================
  99. # Colorize Fortran operators
  100. #
  101. proc fortColorOpers {{color green}} {
  102.     set FortOperators {
  103.         eq ne lt le gt ge not and or eqv neqv true false
  104.     }
  105.     regModeKeywords -a -k $color Fort $FortOperators
  106.     unset FortOperators
  107. }
  108.  
  109. #=========================================================================
  110. # Colorize Fortran function keywords
  111. #
  112. proc fortColorFuncs {{color green}} {
  113.     # Fortran bit functions
  114.     #
  115.     set BitKeywords {
  116.         bit_size btest iand ibclr ibits ibset ieor ior ishft ishftc mvbits not
  117.     }
  118.     regModeKeywords -a -k $color Fort $BitKeywords
  119.     unset BitKeywords
  120.     
  121.     # Fortran intrinsic functions
  122.     #
  123.     set IntrinsicKeywords {
  124.         abs acos aimag asin atan atan2 conjg cos cosh dble dim dprod exp ichar 
  125.         len lge lgt lle llt log log10 max min mod sign sin sinh sqrt tan tanh 
  126.         iabs dabs cabs dacos dint dnint dasin datan datan2 dcos ccos dcosh idim 
  127.         ddim dexp cexp ifix idint alog ddlog clog alog10 dlog10 max0 amax0 max1 
  128.         amax1 dmax1 min0 amin0 min1 amin1 dmin1 amod dmod idnint float sngl 
  129.         isign dsign dsin csin dsinh dsqrt csqrt dtan dtanh aint anint char cmplx 
  130.         index int nint achar adjustl adjustr all allocated any associated 
  131.         bit_size btest ceiling count cshift date_and_time digits dot_product 
  132.         eoshift epsilon exponent floor fraction huge iachar iand ibclr ibits 
  133.         ibset ieor ior ishft ishftc kind lbound len_trim logical matmul 
  134.         maxexponent maxloc maxval merge minexponent minloc minval modulo mvbits 
  135.         nearest not pack precision present product radix random_number 
  136.         random_seed range repeat reshape rrspacing scale scan selected_int_kind 
  137.         selected_real_kind set_exponent shape size spacing spread sum 
  138.         system_clock tiny transfer transpose trim ubound unpack verify
  139.     }
  140.     regModeKeywords -a -k $color Fort $IntrinsicKeywords
  141.     unset IntrinsicKeywords    
  142. }
  143.  
  144. fortColorKeywords blue red black
  145. fortColorCPP green
  146.  
  147. #=============================================================================
  148. # Special Fortran keybindings
  149. #
  150. bind '\[' <c>  FortShiftLeft Fort
  151. bind '\[' <co> FortShiftLeftSpace Fort
  152. bind '\]' <c>  FortShiftRight Fort
  153. bind '\]' <co> FortShiftRightSpace Fort
  154.  
  155. bind '\t'       doATab Fort
  156. bind '\t' <o>     {doATab 1} Fort
  157. bind '\t' <z>     {doATab 1} Fort
  158.  
  159. bind 'j'  <zo> FortBreakLine Fort
  160.  
  161. trace variable FortmodeVars(commentChar) w shadowFort
  162. trace variable FortmodeVars(colorFuncs) w shadowFort
  163. trace variable FortmodeVars(colorOpers) w shadowFort
  164.  
  165. #=============================================================================
  166. # Update colorization when Fortran mode variables are changed
  167. #
  168. proc shadowFort {name1 name2 op} {
  169.     global HOME FortmodeVars
  170.     if {$name1 == "FortmodeVars" && $op == "w"} {
  171.         switch $name2 {
  172.             "colorFuncs"    {
  173.                 if {$FortmodeVars(colorFuncs)} {
  174.                     fortColorFuncs green
  175.                 } else {
  176.                     fortColorFuncs black
  177.                 }
  178.              }
  179.             "colorOpers"    {
  180.                 if {$FortmodeVars(colorOpers)} {
  181.                     fortColorOpers green
  182.                 } else {
  183.                     fortColorOpers black
  184.                 }
  185.              }
  186.             "commentChar" {    
  187.                 fortColorKeywords blue red black
  188.             }
  189.             default {
  190.                 return
  191.             }
  192.         }
  193.     }
  194. }
  195.  
  196. #=============================================================================
  197. #
  198. proc FortMarkFile {} {
  199.     global FortmodeVars
  200.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  201.     
  202.     set pat0 {^.*(subroutine|.*function|entry|program).*$}
  203.     set pat1 {^[^cC*!]([ \ta-z*0-9]*)(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  204.     set end [maxPos]
  205.     set pos 0
  206.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
  207.         regexp -nocase $pat1 [eval getText $mtch] allofit valtyp subtyp name
  208.         set start [lineStart [lindex $mtch 0]]
  209.         set next [nextLineStart $start]
  210.         set pos $next
  211.         if {! [regexp -nocase "end" $valtyp mtch]} {
  212.             set inds([lineStart $start]) $name
  213.         }
  214.         
  215.     }
  216.     
  217.     set pat2 "^(c+${tag})\[ \t\]*(\[^\n\r\]*\[^ \t\])\[^ \t\]*\$"
  218.     set pos 0
  219.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
  220.         regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
  221.         regsub -all {[\/\(\)]} $comment {} comment
  222.         set start [lindex $mtch 0]
  223.         set end [nextLineStart $start]
  224.         set pos $end
  225.         set inds([lineStart $start]) $comment
  226.     }
  227.     
  228.     if {[info exists inds]} {
  229.         foreach f [lsort -integer [array names inds]] {
  230.             set next [nextLineStart $f ]
  231.             setNamedMark $inds($f) $f $f $f
  232.         }
  233.     }
  234. }
  235.  
  236. #================================================================================
  237. # Block shift left and right for Fortran mode (preserves cols 1-6)
  238. #================================================================================
  239.  
  240. proc FortShiftLeft {} {
  241.     global shiftChar
  242.     doFortShiftLeft "\t"
  243.     
  244. }
  245. proc FortShiftLeftSpace {} {
  246.     global shiftChar
  247.     doFortShiftLeft " "
  248. }
  249.  
  250. proc doFortShiftLeft {shiftChar} {
  251.     set start [lineStart [getPos]]
  252.     set end [nextLineStart [expr [selEnd] - 1]]
  253.     if {$start >= $end} {set end [nextLineStart $start]}
  254.     
  255.     set text [split [getText $start [expr $end - 1]] "\r"]
  256.     
  257.     set textout ""
  258.     
  259.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
  260.     foreach line $text {
  261.         if {[regexp $pat $line mtch pref body]} {
  262.             if {[string index $body 0] == $shiftChar} {
  263.                 lappend textout $pref[string range $body 1 end]
  264.             } else {
  265.                 lappend textout $line
  266.             }
  267.  
  268.         } elseif {[string index $line 0] == $shiftChar} {
  269.             lappend textout [string range $line 1 end]
  270.  
  271.         } else {
  272.             lappend textout $line
  273.         }
  274.     }
  275.  
  276.     set text [join $textout "\r"]    
  277.     replaceText $start [expr $end - 1] $text
  278.     select $start [expr 1 + $start + [string length $text]]
  279. }
  280.  
  281. proc FortShiftRight {} {
  282.     global shiftChar
  283.     doFortShiftRight "\t"
  284.     
  285. }
  286. proc FortShiftRightSpace {} {
  287.     global shiftChar
  288.     doFortShiftRight " "
  289. }
  290.  
  291. proc doFortShiftRight {shiftChar} {
  292.     set start [lineStart [getPos]]
  293.     set end [nextLineStart [expr [selEnd] - 1]]
  294.     if {$start >= $end} {set end [nextLineStart $start]}
  295.     
  296.     set text [split [getText $start [expr $end - 1]] "\r"]
  297.     
  298.     set textout ""
  299.     
  300.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
  301.     foreach line $text {
  302.         if {[regexp $pat $line mtch pref body]} {
  303.             lappend textout $pref$shiftChar$body
  304.         } else {
  305.             lappend textout $shiftChar$line
  306.         }
  307.     }
  308.     
  309.     set text [join $textout "\r"]    
  310.     replaceText $start [expr $end - 1] $text
  311.     select $start [expr 1 + $start + [string length $text]]
  312. }
  313.  
  314. proc FortBreakLine {} {
  315.     global FortmodeVars
  316.     set pos [getPos]
  317.     set line [getText [lineStart $pos] [expr [nextLineStart $pos]-1]]
  318.     if {[regexp {^[cC*!]} $line char]} {
  319.         insertText "\n$char "
  320.     } else {
  321.         set char $FortmodeVars(continueChar)
  322.         insertText "\n     $char"
  323.     }
  324.     FortindentLine
  325. }
  326.  
  327. #=============================================================================
  328. # Cmd-double-clicking opens include files, jumps to subroutine definitions,
  329. # and follows tags.
  330. #
  331. proc FortDblClick {from to} {
  332.     global tagFile
  333.     set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
  334.     set incPat {^[^cC*!][ \t]*include[ \t]*['"]([^'"]+)['"]}
  335.  
  336.     # First check whether an 'include' was clicked
  337.     set line [getText [lineStart $from] [expr [nextLineStart $to] - 1]]
  338.     if {[regexp -nocase $incPat $line allofit fname]} {
  339.         set path [absolutePath $fname]
  340.         if {[catch {openFileQuietly $path}]} { 
  341.             message "include file \'$fname\' not found in source folder"
  342.         }
  343.         return
  344.     }
  345.     
  346.     select $from $to
  347.     set text [getSelect]
  348.     
  349.     # First check current file for subroutine definition,...
  350.     if {![catch {fortFindSub $text} mtch]} { 
  351.         regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
  352.         pushMark
  353.         display [lindex $mtch 0]
  354. #         eval select $mtch
  355.         message "press <Ctl .> to return to original cursor position"
  356.  
  357.     # ...then check tags file.
  358.     } else {
  359.         message "Searching tags file..."
  360.         set lines [grep "^$text'" $tagFile]
  361.         if {[regexp {'(.*)'} $lines dummy fname]} { 
  362.             pushMark
  363.             if {[string match "*$fname*" [winNames -f]]} {
  364.                 bringToFront $fname
  365.             } else {
  366.                 edit $fname
  367.             }
  368.             set inds [fortFindSub $text]
  369. #             set inds [search -s -f 1 -r 1 -i 1 "$pat1$text" 0]
  370.             display [lindex $inds 0]
  371. #             eval select $inds
  372.             message "press <Ctl .> to return to original cursor position"
  373.         }
  374.     }
  375. }
  376.  
  377. # Speedy search for a Fortran subroutine.  Performance is dramatically 
  378. # improved by scanning for the name alone first, rather than running 
  379. # complicated regexp search on the entire file.
  380. #
  381. proc fortFindSub {name} {
  382.     set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
  383.     set pos 0
  384.     while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
  385.         set beg [lineStart [lindex $mtch 0]]
  386.         set end [expr [nextLineStart [lindex $mtch 1]] -1]
  387.         set line [getText $beg $end]
  388.         if {[regexp  -nocase $pat1$name $line allofit subtyp name]} {
  389.             return $mtch 
  390.         } else {
  391.             set pos [lindex $mtch 1]
  392.         }
  393.     }
  394.     error "Subroutine \"$name\" not found"
  395. }
  396.  
  397. #=============================================================================
  398. # Fortan auto-indentation
  399. #
  400. # Logic:
  401. #    0.    Identify previous line
  402. #            a) ignore comments and continuation lines
  403. #            b) if current line is a CONTINUE that matches a DO, use the
  404. #                first corresponding DO as the previous line
  405. #
  406. #    1.    Find leading whitespace for previous line
  407. #
  408. #    2.    Increase whitespace if previous line starts a block, i.e.,
  409. #            a) DO loop
  410. #            b) IF ... THEN 
  411. #            c) ELSE
  412. #
  413. #    3.    Decrease whitespace if current line ends a block, i.e.,
  414. #            a) ELSE || ENDIF || END IF || ENDDO || END DO
  415. #            b) <linenum> CONTINUE matching a preceding DO
  416. #
  417. #        or if previous line ends a DO loop on an executable statement, i.e.,
  418. #            c) <linenum> (not CONTINUE) matching a preceding DO
  419. #
  420. ####################################################################################
  421. # Fortan auto-indentation
  422. #
  423. proc FortindentLine {} {    
  424.     set bol [lineStart [getPos]]
  425.     set eol [expr [nextLineStart $bol] - 1]
  426.     Fortindent $bol $eol
  427. }
  428.  
  429. proc FortindentRegion {} {    
  430.     Fortindent [getPos] [selEnd]
  431. }
  432.  
  433. ####################################################################################
  434. # Fortan auto-indentation of a specified region
  435. #
  436. proc Fortindent {pos0 pos1} {
  437.     global fortDooz fortPrevLine fortTop msg
  438.     global FortmodeVars
  439.  
  440.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  441.     set doComment $FortmodeVars(indentComment)
  442.  
  443.     # Define regexps
  444.     set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  445.     set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
  446.     set mtPat {^[ \t]*$}
  447.     set tab "    "
  448.     
  449.     set contPat {^     ([^ \t\n\r])[^\r\n]*$}
  450.     set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
  451.     set comPat "^(\[cC*!\]+(${tag})?)(\[ \t\]*)(.*)\$"
  452.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  453.     set tailPat {[^\r\n]*$}
  454.     
  455.     set bobPat {^(if[^\n\r]*then|else|do)}
  456.     set eobPat {^(end[ \t]*if|end[ \t]*do|else)}
  457.     set enddoPat {^(end[ \t]*do|continue)}
  458.     
  459. #     set fortTop [fortSubTop $pos0]
  460.     set fortTop -1
  461.     
  462.     catch {unset fortDooz}
  463.     set fortPrevLine ""
  464.     
  465.     # Loop over region line by line
  466.     set from [lindex [posToRowCol $pos0] 0]
  467.     set to [lindex [posToRowCol $pos1] 0]
  468.     
  469.     while {$from <= $to} {        
  470.         set msg "Indenting line $from"
  471.         message $msg
  472.         set bol [lineStart [rowColToPos $from 0]]
  473.         set eol [expr [nextLineStart $bol] - 1]
  474.         set thisLine [getText $bol $eol]
  475.         goto $bol
  476.         
  477.         # Check whether we're entering a new routine
  478.         #
  479.         if {[regexp $subPat $thisLine allofit subType subName]} {
  480.             # alertnote "entering subr: \/$subName\/"
  481.             set fortTop $bol
  482.             catch {unset fortDooz}
  483.         } 
  484.         
  485.         # Is the current line a comment line...
  486.         #        
  487.         if {[regexp $comPat $thisLine allofit cc tag pre body]} {
  488.             if {$FortmodeVars(indentComment) > 0} {
  489.                 set body [string trimright $body]
  490.                 # alertnote "comment line: \/$pre\/$body\/"
  491.                 set lwhite "$cc     "
  492.                 
  493.                 replaceText $bol $eol $lwhite$body
  494.             }
  495.             
  496.         # ... or a line of code (possibly empty)?
  497.         #    
  498.         } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
  499.             set body [string trimright $body]
  500.             # alertnote "line: \/$pre\/$lnum\/$post\/$body\/"
  501.             
  502.             # is it a continuation line?
  503.             #
  504.             if {(![regexp {\t} $pre]) && ([string length $pre] == 5)} {
  505.                 set cont [string index $lnum$post$body 0]
  506.                 set body [string trimleft [string range $lnum$post$body 1 end]]
  507.             } else {
  508.                 set cont {}
  509.             }
  510.             # alertnote "cont: \/$cont\/"
  511.             
  512.             # get whitespace for preceding line
  513.             set enddo [getFortPrev $bol $lnum]
  514.             set lwhite [getFortLwhite $bol]
  515.             
  516.             # if this line ends a block, decrease the whitespace
  517.             if {[regexp $eobPat $body] || ($enddo && [regexp -nocase $enddoPat $body])} {
  518.                 set lwlen [expr [string length $lwhite] - 4]
  519.                 set lwhite [string range $lwhite 0 $lwlen]
  520.             } 
  521.             
  522.             if {[string length $lnum]} {
  523.                 if {[string index $lwhite 0] != $tab} {
  524.                     set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
  525.                 }
  526.                 set lnum " $lnum"
  527.             }
  528.             # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
  529.             # message "$msg : replacing text      "
  530.             
  531.             if {[string length $cont]} {
  532.                 replaceText $bol $eol "     $cont$lwhite$body"    
  533.             } else {
  534.                 replaceText $bol $eol $lnum$lwhite$body
  535.                 if {[string length $body] > 0} {
  536.                     set fortPrevLine $lnum$lwhite$body
  537.                 }
  538.             }
  539.         } else {
  540.             # message "$msg : Couldn't parse line         "
  541.         }
  542.         
  543.         # message "$msg : Done                "
  544.         incr from
  545.     }
  546. }
  547.  
  548. proc getFortLwhite {bol} {
  549.     global fortDooz fortPrevLine fortTop msg
  550.     # Define regexps
  551.     set tab "    "
  552.     set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
  553.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  554.     set bobPat {^(if[^\n\r]*then|else|do)}
  555.     set enddoPat {^(end[ \t]*do|continue)}
  556.     
  557.     if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
  558.         # alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"
  559.         
  560.         if {[string length $lnum0]} {
  561.             if {[string index $post0 0] == $tab} {
  562.                 set lwhite $post0
  563.             } else {
  564.                 regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
  565.             }
  566.         } else {
  567.             set lwhite $pre0
  568.         }
  569.         # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
  570.         # message "$msg : got lwhite (initial)"
  571.         
  572.         # if there's a line number and it's not a CONTINUE or ENDDO, 
  573.         # then check for a matching DO statement and adjust 
  574.         # indentation if found
  575.         #
  576.         if {[string length $lnum0] && ![regexp -nocase $enddoPat $body0]} {
  577.             if {[getFortPrev [lineStart [expr $bol - 1]] $lnum0]} {
  578.                 set lwlen [expr [string length $lwhite] - 4]
  579.                 set lwhite [string range $lwhite 0 $lwlen]
  580.  
  581.             }
  582.         }
  583.         
  584.         # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
  585.         # then increase the whitespace
  586.         #    
  587.         if {[regexp -nocase $bobPat $body0]} {
  588.             set lwhite "$lwhite   "
  589.             
  590.             if {[regexp -nocase "$doPat\(\[0-9\]+\)" $body0 mtch donum]} {
  591.                 set eol [expr [nextLineStart $bol] - 1]
  592.                 set fortDooz($donum) [getText $bol $eol]
  593.             }
  594.         }
  595.         # message "$msg : got lwhite (final)  "
  596.     }
  597.     return "$lwhite"
  598. }
  599.  
  600. proc getFortPrev {bol lnum} {        
  601.     global fortDooz fortPrevLine fortTop msg
  602.     # Define regexps
  603.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  604.     set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
  605.     set contPat {^     ([^ \t\n\r])[^\r\n]*$}
  606.  
  607.     # if there's a line number, check for a matching DO statement ...
  608.     if {[string length $lnum]} {
  609.         if {[lsearch [array names fortDooz] $lnum] >= 0} {
  610.             set fortPrevLine $fortDooz($lnum)
  611.             return 1
  612.         } else {
  613.             if {$fortTop < 0} {
  614.                 set fortTop [fortSubTop $bol]
  615.             }
  616.             if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
  617.                 set fortPrevLine [eval getText $dolst]
  618.                 set fortDooz($lnum) $fortPrevLine
  619.                 # alertnote "doLine0: \/$fortPrevLine\/"
  620.                 return 1
  621.             }
  622.         }
  623.     }
  624.         
  625.     # ... otherwise find the first preceding non-comment, non-continuation line
  626.     if {[string length $fortPrevLine] == 0} {
  627.         if {[catch {
  628.             set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
  629.             set fortPrevLine [eval getText $lst]
  630.             while {[regexp -nocase $contPat $fortPrevLine]} {
  631.                 set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
  632.                 set fortPrevLine [eval getText $lst]
  633.             }
  634.         }]} {
  635.             # if search fails, we're at the top of a file, so reset indentation
  636.             set fortPrevLine "      continue"
  637.         }
  638.     }
  639.     
  640.     # alertnote "prevLine: \/$fortPrevLine\/"
  641.     # message "$msg : got prevLine"
  642.     return 0
  643. }
  644.  
  645. # Find the beginning of the current subroutine
  646. #
  647. proc fortSubTop {{pos 0}} {
  648.     if {$pos == 0} {
  649.         set pos [lineStart [getPos]]
  650.     }
  651.     set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  652.     
  653.     if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
  654.         # set subLine [eval getText $sublst]
  655.         # alertnote "subLine: \/$subLine\/"
  656.         return [lindex $sublst 0]
  657.     } else {
  658.         return 0
  659.     } 
  660. }